home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tk8.0 / xmfbox.tcl < prev   
Encoding:
Text File  |  1998-12-04  |  15.9 KB  |  636 lines
  1. # xmfbox.tcl --
  2. #
  3. #    Implements the "Motif" style file selection dialog for the
  4. #    Unix platform. This implementation is used only if the
  5. #    "tk_strictMotif" flag is set.
  6. #
  7. # SCCS: @(#) xmfbox.tcl 1.6 97/10/01 15:06:07
  8. #
  9. # Copyright (c) 1996 Sun Microsystems, Inc.
  10. #
  11. # See the file "license.terms" for information on usage and redistribution
  12. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13. #
  14.  
  15.  
  16. # tkMotifFDialog --
  17. #
  18. #    Implements a file dialog similar to the standard Motif file
  19. #    selection box.
  20. #
  21. # Return value:
  22. #
  23. #    A list of two members. The first member is the absolute
  24. #    pathname of the selected file or "" if user hits cancel. The
  25. #    second member is the name of the selected file type, or ""
  26. #    which stands for "default file type"
  27. #
  28. proc tkMotifFDialog {args} {
  29.     global tkPriv
  30.     set w __tk_filedialog
  31.     upvar #0 $w data
  32.  
  33.     if ![string compare [lindex [info level 0] 0] tk_getOpenFile] {
  34.     set type open
  35.     } else {
  36.     set type save
  37.     }
  38.  
  39.     tkMotifFDialog_Config $w $type $args
  40.  
  41.     if {![string compare $data(-parent) .]} {
  42.         set w .$w
  43.     } else {
  44.         set w $data(-parent).$w
  45.     }
  46.  
  47.     # (re)create the dialog box if necessary
  48.     #
  49.     if {![winfo exists $w]} {
  50.     tkMotifFDialog_Create $w
  51.     } elseif {[string compare [winfo class $w] TkMotifFDialog]} {
  52.     destroy $w
  53.     tkMotifFDialog_Create $w
  54.     }
  55.     wm transient $w $data(-parent)
  56.  
  57.     tkMotifFDialog_Update $w
  58.  
  59.     # 5. Withdraw the window, then update all the geometry information
  60.     # so we know how big it wants to be, then center the window in the
  61.     # display and de-iconify it.
  62.  
  63.     wm withdraw $w
  64.     update idletasks
  65.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  66.         - [winfo vrootx [winfo parent $w]]]
  67.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  68.         - [winfo vrooty [winfo parent $w]]]
  69.     wm geom $w +$x+$y
  70.     wm deiconify $w
  71.     wm title $w $data(-title)
  72.  
  73.     # 6. Set a grab and claim the focus too.
  74.  
  75.     set oldFocus [focus]
  76.     set oldGrab [grab current $w]
  77.     if {$oldGrab != ""} {
  78.     set grabStatus [grab status $oldGrab]
  79.     }
  80.     grab $w
  81.     focus $data(sEnt)
  82.     $data(sEnt) select from 0
  83.     $data(sEnt) select to   end
  84.  
  85.     # 7. Wait for the user to respond, then restore the focus and
  86.     # return the index of the selected button.  Restore the focus
  87.     # before deleting the window, since otherwise the window manager
  88.     # may take the focus away so we can't redirect it.  Finally,
  89.     # restore any grab that was in effect.
  90.  
  91.     tkwait variable tkPriv(selectFilePath)
  92.     catch {focus $oldFocus}
  93.     grab release $w
  94.     wm withdraw $w
  95.     if {$oldGrab != ""} {
  96.     if {$grabStatus == "global"} {
  97.         grab -global $oldGrab
  98.     } else {
  99.         grab $oldGrab
  100.     }
  101.     }
  102.     return $tkPriv(selectFilePath)
  103. }
  104.  
  105. proc tkMotifFDialog_Config {w type argList} {
  106.     upvar #0 $w data
  107.  
  108.     set data(type) $type
  109.  
  110.     # 1: the configuration specs
  111.     #
  112.     set specs {
  113.     {-defaultextension "" "" ""}
  114.     {-filetypes "" "" ""}
  115.     {-initialdir "" "" ""}
  116.     {-initialfile "" "" ""}
  117.     {-parent "" "" "."}
  118.     {-title "" "" ""}
  119.     }
  120.  
  121.     # 2: default values depending on the type of the dialog
  122.     #
  123.     if ![info exists data(selectPath)] {
  124.     # first time the dialog has been popped up
  125.     set data(selectPath) [pwd]
  126.     set data(selectFile) ""
  127.     }
  128.  
  129.     # 3: parse the arguments
  130.     #
  131.     tclParseConfigSpec $w $specs "" $argList
  132.  
  133.     if ![string compare $data(-title) ""] {
  134.     if ![string compare $type "open"] {
  135.         set data(-title) "Open"
  136.     } else {
  137.         set data(-title) "Save As"
  138.     }
  139.     }
  140.  
  141.     # 4: set the default directory and selection according to the -initial
  142.     #    settings
  143.     #
  144.     if [string compare $data(-initialdir) ""] {
  145.     if [file isdirectory $data(-initialdir)] {
  146.         set data(selectPath) [glob $data(-initialdir)]
  147.     } else {
  148.         error "\"$data(-initialdir)\" is not a valid directory"
  149.     }
  150.     }
  151.     set data(selectFile) $data(-initialfile)
  152.  
  153.     # 5. Parse the -filetypes option. It is not used by the motif
  154.     #    file dialog, but we check for validity of the value to make sure
  155.     #    the application code also runs fine with the TK file dialog.
  156.     #
  157.     set data(-filetypes) [tkFDGetFileTypes $data(-filetypes)]
  158.  
  159.     if ![info exists data(filter)] {
  160.     set data(filter) *
  161.     }
  162.     if ![winfo exists $data(-parent)] {
  163.     error "bad window path name \"$data(-parent)\""
  164.     }
  165. }
  166.  
  167. proc tkMotifFDialog_Create {w} {
  168.     set dataName [lindex [split $w .] end]
  169.     upvar #0 $dataName data
  170.  
  171.     # 1: Create the dialog ...
  172.     #
  173.     toplevel $w -class TkMotifFDialog
  174.     set top [frame $w.top -relief raised -bd 1]
  175.     set bot [frame $w.bot -relief raised -bd 1]
  176.  
  177.     pack $w.bot -side bottom -fill x
  178.     pack $w.top -side top -expand yes -fill both
  179.  
  180.     set f1 [frame $top.f1]
  181.     set f2 [frame $top.f2]
  182.     set f3 [frame $top.f3]
  183.  
  184.     pack $f1 -side top    -fill x
  185.     pack $f3 -side bottom -fill x
  186.     pack $f2 -expand yes -fill both
  187.  
  188.     set f2a [frame $f2.a]
  189.     set f2b [frame $f2.b]
  190.  
  191.     grid $f2a -row 0 -column 0 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
  192.     -sticky news
  193.     grid $f2b -row 0 -column 1 -rowspan 1 -columnspan 1 -padx 4 -pady 4 \
  194.     -sticky news
  195.     grid rowconfig $f2 0    -minsize 0   -weight 1
  196.     grid columnconfig $f2 0 -minsize 0   -weight 1
  197.     grid columnconfig $f2 1 -minsize 150 -weight 2
  198.  
  199.     # The Filter box
  200.     #
  201.     label $f1.lab -text "Filter:" -under 3 -anchor w
  202.     entry $f1.ent
  203.     pack $f1.lab -side top -fill x -padx 6 -pady 4
  204.     pack $f1.ent -side top -fill x -padx 4 -pady 0
  205.     set data(fEnt) $f1.ent
  206.  
  207.     # The file and directory lists
  208.     #
  209.     set data(dList) [tkMotifFDialog_MakeSList $w $f2a Directory: 0 DList]
  210.     set data(fList) [tkMotifFDialog_MakeSList $w $f2b Files:     2 FList]
  211.  
  212.     # The Selection box
  213.     #
  214.     label $f3.lab -text "Selection:" -under 0 -anchor w
  215.     entry $f3.ent
  216.     pack $f3.lab -side top -fill x -padx 6 -pady 0
  217.     pack $f3.ent -side top -fill x -padx 4 -pady 4
  218.     set data(sEnt) $f3.ent
  219.  
  220.     # The buttons
  221.     #
  222.     set data(okBtn) [button $bot.ok     -text OK     -width 6 -under 0 \
  223.     -command "tkMotifFDialog_OkCmd $w"]
  224.     set data(filterBtn) [button $bot.filter -text Filter -width 6 -under 0 \
  225.     -command "tkMotifFDialog_FilterCmd $w"]
  226.     set data(cancelBtn) [button $bot.cancel -text Cancel -width 6 -under 0 \
  227.     -command "tkMotifFDialog_CancelCmd $w"]
  228.  
  229.     pack $bot.ok $bot.filter $bot.cancel -padx 10 -pady 10 -expand yes \
  230.     -side left
  231.  
  232.     # Create the bindings:
  233.     #
  234.     bind $w <Alt-t> "focus $data(fEnt)"
  235.     bind $w <Alt-d> "focus $data(dList)"
  236.     bind $w <Alt-l> "focus $data(fList)"
  237.     bind $w <Alt-s> "focus $data(sEnt)"
  238.  
  239.     bind $w <Alt-o> "tkButtonInvoke $bot.ok    "
  240.     bind $w <Alt-f> "tkButtonInvoke $bot.filter"
  241.     bind $w <Alt-c> "tkButtonInvoke $bot.cancel"
  242.  
  243.     bind $data(fEnt) <Return> "tkMotifFDialog_ActivateFEnt $w"
  244.     bind $data(sEnt) <Return> "tkMotifFDialog_ActivateSEnt $w"
  245.  
  246.     wm protocol $w WM_DELETE_WINDOW "tkMotifFDialog_CancelCmd $w"
  247. }
  248.  
  249. proc tkMotifFDialog_MakeSList {w f label under cmd} {
  250.     label $f.lab -text $label -under $under -anchor w
  251.     listbox $f.l -width 12 -height 5 -selectmode browse -exportselection 0\
  252.     -xscrollcommand "$f.h set" \
  253.     -yscrollcommand "$f.v set" 
  254.     scrollbar $f.v -orient vertical   -takefocus 0 \
  255.     -command "$f.l yview"
  256.     scrollbar $f.h -orient horizontal -takefocus 0 \
  257.     -command "$f.l xview"
  258.     grid $f.lab -row 0 -column 0 -sticky news -rowspan 1 -columnspan 2 \
  259.     -padx 2 -pady 2
  260.     grid $f.l -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
  261.     grid $f.v -row 1 -column 1 -rowspan 1 -columnspan 1 -sticky news
  262.     grid $f.h -row 2 -column 0 -rowspan 1 -columnspan 1 -sticky news
  263.  
  264.     grid rowconfig    $f 0 -weight 0 -minsize 0
  265.     grid rowconfig    $f 1 -weight 1 -minsize 0
  266.     grid columnconfig $f 0 -weight 1 -minsize 0
  267.  
  268.     # bindings for the listboxes
  269.     #
  270.     set list $f.l
  271.     bind $list <Up>        "tkMotifFDialog_Browse$cmd $w"
  272.     bind $list <Down>      "tkMotifFDialog_Browse$cmd $w"
  273.     bind $list <space>     "tkMotifFDialog_Browse$cmd $w"
  274.     bind $list <1>         "tkMotifFDialog_Browse$cmd $w"
  275.     bind $list <B1-Motion> "tkMotifFDialog_Browse$cmd $w"
  276.     bind $list <Double-1>  "tkMotifFDialog_Activate$cmd $w"
  277.     bind $list <Return>    "tkMotifFDialog_Browse$cmd $w; tkMotifFDialog_Activate$cmd $w"
  278.  
  279.     bindtags $list "Listbox $list [winfo toplevel $list] all"
  280.     tkListBoxKeyAccel_Set $list
  281.  
  282.     return $f.l
  283. }
  284.  
  285. proc tkMotifFDialog_BrowseDList {w} {
  286.     upvar #0 [winfo name $w] data
  287.  
  288.     focus $data(dList)
  289.     if ![string compare [$data(dList) curselection] ""] {
  290.     return
  291.     }
  292.     set subdir [$data(dList) get [$data(dList) curselection]]
  293.     if ![string compare $subdir ""] {
  294.     return
  295.     }
  296.  
  297.     $data(fList) selection clear 0 end
  298.  
  299.     set list [tkMotifFDialog_InterpFilter $w]
  300.     set data(filter) [lindex $list 1]
  301.  
  302.     case $subdir {
  303.     . {
  304.         set newSpec [file join $data(selectPath) $data(filter)]
  305.     }
  306.     .. {
  307.         set newSpec [file join [file dirname $data(selectPath)] \
  308.         $data(filter)]
  309.     }
  310.     default {
  311.         set newSpec [file join $data(selectPath) $subdir $data(filter)]
  312.     }
  313.     }
  314.  
  315.     $data(fEnt) delete 0 end
  316.     $data(fEnt) insert 0 $newSpec
  317. }
  318.  
  319. proc tkMotifFDialog_ActivateDList {w} {
  320.     upvar #0 [winfo name $w] data
  321.  
  322.     if ![string compare [$data(dList) curselection] ""] {
  323.     return
  324.     }
  325.     set subdir [$data(dList) get [$data(dList) curselection]]
  326.     if ![string compare $subdir ""] {
  327.     return
  328.     }
  329.  
  330.     $data(fList) selection clear 0 end
  331.  
  332.     case $subdir {
  333.     . {
  334.         set newDir $data(selectPath)
  335.     }
  336.     .. {
  337.         set newDir [file dirname $data(selectPath)]
  338.     }
  339.     default {
  340.         set newDir [file join $data(selectPath) $subdir]
  341.     }
  342.     }
  343.  
  344.     set data(selectPath) $newDir
  345.     tkMotifFDialog_Update $w
  346.  
  347.     if [string compare $subdir ..] {
  348.     $data(dList) selection set 0
  349.     $data(dList) activate 0
  350.     } else {
  351.     $data(dList) selection set 1
  352.     $data(dList) activate 1
  353.     }
  354. }
  355.  
  356. proc tkMotifFDialog_BrowseFList {w} {
  357.     upvar #0 [winfo name $w] data
  358.  
  359.     focus $data(fList)
  360.     if ![string compare [$data(fList) curselection] ""] {
  361.     return
  362.     }
  363.     set data(selectFile) [$data(fList) get [$data(fList) curselection]]
  364.     if ![string compare $data(selectFile) ""] {
  365.     return
  366.     }
  367.  
  368.     $data(dList) selection clear 0 end
  369.  
  370.     $data(fEnt) delete 0 end
  371.     $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
  372.     $data(fEnt) xview end
  373.  
  374.     $data(sEnt) delete 0 end
  375.     $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
  376.     $data(sEnt) xview end
  377. }
  378.  
  379. proc tkMotifFDialog_ActivateFList {w} {
  380.     upvar #0 [winfo name $w] data
  381.  
  382.     if ![string compare [$data(fList) curselection] ""] {
  383.     return
  384.     }
  385.     set data(selectFile) [$data(fList) get [$data(fList) curselection]]
  386.     if ![string compare $data(selectFile) ""] {
  387.     return
  388.     } else {
  389.     tkMotifFDialog_ActivateSEnt $w
  390.     }
  391. }
  392.  
  393. proc tkMotifFDialog_ActivateFEnt {w} {
  394.     upvar #0 [winfo name $w] data
  395.  
  396.     set list [tkMotifFDialog_InterpFilter $w]
  397.     set data(selectPath) [lindex $list 0]
  398.     set data(filter)    [lindex $list 1]
  399.  
  400.     tkMotifFDialog_Update $w
  401. }
  402.  
  403. proc tkMotifFDialog_InterpFilter {w} {
  404.     upvar #0 [winfo name $w] data
  405.  
  406.     set text [string trim [$data(fEnt) get]]
  407.     # Perform tilde substitution
  408.     #
  409.     if ![string compare [string index $text 0] ~] {
  410.     set list [file split $text]
  411.     set tilde [lindex $list 0]
  412.     catch {
  413.         set tilde [glob $tilde]
  414.     }
  415.     set text [eval file join [concat $tilde [lrange $list 1 end]]]
  416.     }
  417.  
  418.     set resolved [file join [file dirname $text] [file tail $text]]
  419.  
  420.     if [file isdirectory $resolved] {
  421.     set dir $resolved
  422.     set fil $data(filter)
  423.     } else {
  424.     set dir [file dirname $resolved]
  425.     set fil [file tail    $resolved]
  426.     }
  427.  
  428.     return [list $dir $fil]
  429. }
  430.  
  431.  
  432. proc tkMotifFDialog_ActivateSEnt {w} {
  433.     global tkPriv
  434.     upvar #0 [winfo name $w] data
  435.  
  436.     set selectFilePath [string trim [$data(sEnt) get]]
  437.     set selectFile     [file tail    $selectFilePath]
  438.     set selectPath     [file dirname $selectFilePath]
  439.  
  440.  
  441.     if {![string compare $selectFilePath ""]} {
  442.     tkMotifFDialog_FilterCmd $w
  443.     return
  444.     }
  445.  
  446.     if {[file isdirectory $selectFilePath]} {
  447.     set data(selectPath) [glob $selectFilePath]
  448.     set data(selectFile) ""
  449.     tkMotifFDialog_Update $w
  450.     return
  451.     }
  452.  
  453.     if [string compare [file pathtype $selectFilePath] "absolute"] {
  454.     tk_messageBox -icon warning -type ok \
  455.         -message "\"$selectFilePath\" must be an absolute pathname"
  456.     return
  457.     }
  458.  
  459.     if ![file exists $selectPath] {
  460.     tk_messageBox -icon warning -type ok \
  461.         -message "Directory \"$selectPath\" does not exist."
  462.     return
  463.     }
  464.  
  465.     if ![file exists $selectFilePath] {
  466.     if ![string compare $data(type) open] {
  467.         tk_messageBox -icon warning -type ok \
  468.         -message "File \"$selectFilePath\" does not exist."
  469.         return
  470.     }
  471.     } else {
  472.     if ![string compare $data(type) save] {
  473.         set message [format %s%s \
  474.         "File \"$selectFilePath\" already exists.\n\n" \
  475.         "Replace existing file?"]
  476.         set answer [tk_messageBox -icon warning -type yesno \
  477.         -message $message]
  478.         if ![string compare $answer "no"] {
  479.         return
  480.         }
  481.     }
  482.     }
  483.  
  484.     set tkPriv(selectFilePath) $selectFilePath
  485.     set tkPriv(selectFile)     $selectFile
  486.     set tkPriv(selectPath)     $selectPath
  487. }
  488.  
  489.  
  490. proc tkMotifFDialog_OkCmd {w} {
  491.     upvar #0 [winfo name $w] data
  492.  
  493.     tkMotifFDialog_ActivateSEnt $w
  494. }
  495.  
  496. proc tkMotifFDialog_FilterCmd {w} {
  497.     upvar #0 [winfo name $w] data
  498.  
  499.     tkMotifFDialog_ActivateFEnt $w
  500. }
  501.  
  502. proc tkMotifFDialog_CancelCmd {w} {
  503.     global tkPriv
  504.  
  505.     set tkPriv(selectFilePath) ""
  506.     set tkPriv(selectFile)     ""
  507.     set tkPriv(selectPath)     ""
  508. }
  509.  
  510. # tkMotifFDialog_Update
  511. #
  512. #    Load the files and synchronize the "filter" and "selection" fields
  513. #    boxes.
  514. #
  515. # popup:
  516. #    If this is true, then update the selection field according to the
  517. #    "-selection" flag
  518. #
  519. proc tkMotifFDialog_Update {w} {
  520.     upvar #0 [winfo name $w] data
  521.  
  522.     $data(fEnt) delete 0 end
  523.     $data(fEnt) insert 0 [file join $data(selectPath) $data(filter)]
  524.     $data(sEnt) delete 0 end
  525.     $data(sEnt) insert 0 [file join $data(selectPath) $data(selectFile)]
  526.  
  527.     tkMotifFDialog_LoadFiles $w
  528. }
  529.  
  530. proc tkMotifFDialog_LoadFiles {w} {
  531.     upvar #0 [winfo name $w] data
  532.  
  533.     $data(dList) delete 0 end
  534.     $data(fList) delete 0 end
  535.  
  536.     set appPWD [pwd]
  537.     if [catch {
  538.     cd $data(selectPath)
  539.     }] {
  540.     cd $appPWD
  541.  
  542.     $data(dList) insert end ".."
  543.     return
  544.     }
  545.  
  546.     # Make the dir list
  547.     #
  548.     foreach f [lsort -command tclSortNoCase [glob -nocomplain .* *]] {
  549.     if [file isdir $f] {
  550.         $data(dList) insert end $f
  551.     }
  552.     }
  553.     # Make the file list
  554.     #
  555.     if ![string compare $data(filter) *] {
  556.     set files [lsort -command tclSortNoCase [glob -nocomplain .* *]]
  557.     } else {
  558.     set files [lsort -command tclSortNoCase \
  559.         [glob -nocomplain $data(filter)]]
  560.     }
  561.  
  562.     set top 0
  563.     foreach f $files {
  564.     if ![file isdir $f] {
  565.         $data(fList) insert end $f
  566.         if [string match .* $f] {
  567.         incr top
  568.         }
  569.     }
  570.     }
  571.  
  572.     # The user probably doesn't want to see the . files. We adjust the view
  573.     # so that the listbox displays all the non-dot files
  574.     $data(fList) yview $top
  575.  
  576.     cd $appPWD
  577. }
  578.  
  579. proc tkListBoxKeyAccel_Set {w} {
  580.     bind Listbox <Any-KeyPress> ""
  581.     bind $w <Destroy> "tkListBoxKeyAccel_Unset $w"
  582.     bind $w <Any-KeyPress> "tkListBoxKeyAccel_Key $w %A"
  583. }
  584.  
  585. proc tkListBoxKeyAccel_Unset {w} {
  586.     global tkPriv
  587.  
  588.     catch {after cancel $tkPriv(lbAccel,$w,afterId)}
  589.     catch {unset tkPriv(lbAccel,$w)}
  590.     catch {unset tkPriv(lbAccel,$w,afterId)}
  591. }
  592.  
  593. proc tkListBoxKeyAccel_Key {w key} {
  594.     global tkPriv
  595.  
  596.     append tkPriv(lbAccel,$w) $key
  597.     tkListBoxKeyAccel_Goto $w $tkPriv(lbAccel,$w)
  598.     catch {
  599.     after cancel $tkPriv(lbAccel,$w,afterId)
  600.     }
  601.     set tkPriv(lbAccel,$w,afterId) [after 500 tkListBoxKeyAccel_Reset $w]
  602. }
  603.  
  604. proc tkListBoxKeyAccel_Goto {w string} {
  605.     global tkPriv
  606.  
  607.     set string [string tolower $string]
  608.     set end [$w index end]
  609.     set theIndex -1
  610.  
  611.     for {set i 0} {$i < $end} {incr i} {
  612.     set item [string tolower [$w get $i]]
  613.     if {[string compare $string $item] >= 0} {
  614.         set theIndex $i
  615.     }
  616.     if {[string compare $string $item] <= 0} {
  617.         set theIndex $i
  618.         break
  619.     }
  620.     }
  621.  
  622.     if {$theIndex >= 0} {
  623.     $w selection clear 0 end
  624.     $w selection set $theIndex $theIndex
  625.     $w activate $theIndex
  626.     $w see $theIndex
  627.     }
  628. }
  629.  
  630. proc tkListBoxKeyAccel_Reset {w} {
  631.     global tkPriv
  632.  
  633.     catch {unset tkPriv(lbAccel,$w)}
  634. }
  635.  
  636.